home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / constant.pm < prev    next >
Text File  |  2008-07-24  |  4KB  |  131 lines
  1. package constant;
  2. use 5.005;
  3. use strict;
  4. use warnings::register;
  5.  
  6. use vars qw($VERSION %declared);
  7. $VERSION = '1.13';
  8.  
  9. #=======================================================================
  10.  
  11. # Some names are evil choices.
  12. my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
  13. $keywords{UNITCHECK}++ if $] > 5.009;
  14.  
  15. my %forced_into_main = map +($_, 1),
  16.     qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
  17.  
  18. my %forbidden = (%keywords, %forced_into_main);
  19.  
  20. #=======================================================================
  21. # import() - import symbols into user's namespace
  22. #
  23. # What we actually do is define a function in the caller's namespace
  24. # which returns the value. The function we create will normally
  25. # be inlined as a constant, thereby avoiding further sub calling 
  26. # overhead.
  27. #=======================================================================
  28. sub import {
  29.     my $class = shift;
  30.     return unless @_;            # Ignore 'use constant;'
  31.     my $constants;
  32.     my $multiple  = ref $_[0];
  33.     my $pkg = caller;
  34.     my $symtab;
  35.     my $str_end = $] >= 5.006 ? "\\z" : "\\Z";
  36.  
  37.     if ($] > 5.009002) {
  38.     no strict 'refs';
  39.     $symtab = \%{$pkg . '::'};
  40.     };
  41.  
  42.     if ( $multiple ) {
  43.     if (ref $_[0] ne 'HASH') {
  44.         require Carp;
  45.         Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
  46.     }
  47.     $constants = shift;
  48.     } else {
  49.     $constants->{+shift} = undef;
  50.     }
  51.  
  52.     foreach my $name ( keys %$constants ) {
  53.     unless (defined $name) {
  54.         require Carp;
  55.         Carp::croak("Can't use undef as constant name");
  56.     }
  57.  
  58.     # Normal constant name
  59.     if ($name =~ /^_?[^\W_0-9]\w*$str_end/ and !$forbidden{$name}) {
  60.         # Everything is okay
  61.  
  62.     # Name forced into main, but we're not in main. Fatal.
  63.     } elsif ($forced_into_main{$name} and $pkg ne 'main') {
  64.         require Carp;
  65.         Carp::croak("Constant name '$name' is forced into main::");
  66.  
  67.     # Starts with double underscore. Fatal.
  68.     } elsif ($name =~ /^__/) {
  69.         require Carp;
  70.         Carp::croak("Constant name '$name' begins with '__'");
  71.  
  72.     # Maybe the name is tolerable
  73.     } elsif ($name =~ /^[A-Za-z_]\w*$str_end/) {
  74.         # Then we'll warn only if you've asked for warnings
  75.         if (warnings::enabled()) {
  76.         if ($keywords{$name}) {
  77.             warnings::warn("Constant name '$name' is a Perl keyword");
  78.         } elsif ($forced_into_main{$name}) {
  79.             warnings::warn("Constant name '$name' is " .
  80.             "forced into package main::");
  81.         }
  82.         }
  83.  
  84.     # Looks like a boolean
  85.     # use constant FRED == fred;
  86.     } elsif ($name =~ /^[01]?$str_end/) {
  87.             require Carp;
  88.         if (@_) {
  89.         Carp::croak("Constant name '$name' is invalid");
  90.         } else {
  91.         Carp::croak("Constant name looks like boolean value");
  92.         }
  93.  
  94.     } else {
  95.        # Must have bad characters
  96.             require Carp;
  97.         Carp::croak("Constant name '$name' has invalid characters");
  98.     }
  99.  
  100.     {
  101.         no strict 'refs';
  102.         my $full_name = "${pkg}::$name";
  103.         $declared{$full_name}++;
  104.         if ($multiple || @_ == 1) {
  105.         my $scalar = $multiple ? $constants->{$name} : $_[0];
  106.         if ($symtab && !exists $symtab->{$name}) {
  107.             # No typeglob yet, so we can use a reference as space-
  108.             # efficient proxy for a constant subroutine
  109.             # The check in Perl_ck_rvconst knows that inlinable
  110.             # constants from cv_const_sv are read only. So we have to:
  111.             Internals::SvREADONLY($scalar, 1);
  112.             $symtab->{$name} = \$scalar;
  113.             mro::method_changed_in($pkg);
  114.         } else {
  115.             *$full_name = sub () { $scalar };
  116.         }
  117.         } elsif (@_) {
  118.         my @list = @_;
  119.         *$full_name = sub () { @list };
  120.         } else {
  121.         *$full_name = sub () { };
  122.         }
  123.     }
  124.     }
  125. }
  126.  
  127. 1;
  128.  
  129. __END__
  130.  
  131.